home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / eval.c < prev    next >
C/C++ Source or Header  |  1987-06-04  |  17KB  |  986 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     eval.c
  9. */
  10.  
  11. #include "include.h"
  12.  
  13. struct nil3 { object nil3_self[3]; } three_nils;
  14.  
  15. #undef endp
  16.  
  17. #define    endp(obje)    ((enum type)((endp_temp = (obje))->d.t) == t_cons ? \
  18.              FALSE : endp_temp == Cnil ? TRUE : \
  19.              (bool)FEwrong_type_argument(Slist, endp_temp))
  20.  
  21. object endp_temp;
  22.  
  23. int eval1 = 0;
  24.  
  25. object Vevalhook;
  26. object Vapplyhook;
  27.  
  28. static object temporary;
  29.  
  30. object Sapply;
  31. object Sfuncall;
  32.  
  33. funcall(fun)
  34. object fun;
  35. {
  36.     object x;
  37.     object *top, *lex;
  38.     bds_ptr old_bds_top;
  39.     bool b, c;
  40.  
  41.     if (fun == OBJNULL)
  42.         FEerror("Undefined function.", 0);
  43.     switch (type_of(fun)) {
  44.     case t_cfun:
  45.         MMcall(fun);
  46.         return;
  47.  
  48.     case t_cclosure:
  49.     {
  50.         object *top, *base, l;
  51.  
  52.         if (fun->cc.cc_turbo != NULL) {
  53.             MMccall(fun, fun->cc.cc_turbo);
  54.             return;
  55.         }
  56.         top = vs_top;
  57.         base = vs_base;
  58.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  59.             vs_push(l);
  60.         vs_base = vs_top;
  61.         while (base < top)
  62.             vs_push(*base++);
  63.         MMccall(fun, top);
  64.         return;
  65.     }
  66.  
  67.     case t_cons:
  68.         break;
  69.  
  70.     default:
  71.         FEinvalid_function(fun);
  72.     }
  73.  
  74.     /*
  75.         This part is the same as that of funcall_no_event.
  76.     */
  77.     ihs_check;
  78.     ihs_push(fun);
  79.     ihs_top->ihs_base = lex_env;
  80.     x = MMcar(fun);
  81.     top = vs_top;
  82.     lex = lex_env;
  83.     old_bds_top = bds_top;
  84.     if (x == Slambda_block) {
  85.         b = TRUE;
  86.         c = FALSE;
  87.         fun = fun->c.c_cdr;
  88.     } else if (x == Slambda_closure) {
  89.         b = FALSE;
  90.         c = TRUE;
  91.         fun = fun->c.c_cdr;
  92.     } else if (x == Slambda) {
  93.         b = c = FALSE;
  94.         fun = fun->c.c_cdr;
  95.     } else if (x == Slambda_block_closure) {
  96.         b = c = TRUE;
  97.         fun = fun->c.c_cdr;
  98.     } else
  99.         b = c = TRUE;
  100.     if (c) {
  101.         vs_push(kar(fun));
  102.         fun = fun->c.c_cdr;
  103.         vs_push(kar(fun));
  104.         fun = fun->c.c_cdr;
  105.         vs_push(kar(fun));
  106.         fun = fun->c.c_cdr;
  107.     } else {
  108.         *(struct nil3 *)vs_top = three_nils;
  109.         vs_top += 3;
  110.     }
  111.     if (b) {
  112.         x = kar(fun);  /* block name */
  113.         fun = fun->c.c_cdr;
  114.     }
  115.     lex_env = top;
  116.     vs_push(fun);
  117.         lambda_bind(top);
  118.     ihs_top->ihs_base = lex_env;
  119.     if (b) {
  120.         fun = temporary = alloc_frame_id();
  121.         /*  lex_block_bind(x, temporary);  */
  122.         temporary = MMcons(temporary, Cnil);
  123.         temporary = MMcons(Sblock, temporary);
  124.         temporary = MMcons(x, temporary);
  125.         lex_env[2] = MMcons(temporary, lex_env[2]);
  126.         frs_push(FRS_CATCH, fun);
  127.         if (nlj_active) {
  128.             nlj_active = FALSE;
  129.             goto END;
  130.         }
  131.     }
  132.     x = top[3];  /* body */
  133.     if(endp(x)) {
  134.         vs_base = vs_top;
  135.         vs_push(Cnil);
  136.     } else {
  137.         top = vs_top;
  138.         for (;;) {
  139.             eval(MMcar(x));
  140.             x = MMcdr(x);
  141.             if (endp(x))
  142.                 break;
  143.             vs_top = top;
  144.         }
  145.     }
  146. END:
  147.     if (b)
  148.         frs_pop();
  149.     bds_unwind(old_bds_top);
  150.     lex_env = lex;
  151.     ihs_pop();
  152. }
  153.  
  154. funcall_no_event(fun)
  155. object fun;
  156. {
  157.     if (fun == OBJNULL)
  158.         FEerror("Undefined function.", 0);
  159.     switch (type_of(fun)) {
  160.     case t_cfun:
  161.         (*fun->cf.cf_self)();
  162.         break;
  163.  
  164.     case t_cclosure:
  165.     {
  166.         object *top, *base, l;
  167.  
  168.         if (fun->cc.cc_turbo != NULL) {
  169.             (*fun->cc.cc_self)(fun->cc.cc_turbo);
  170.             break;
  171.         }
  172.         top = vs_top;
  173.         base = vs_base;
  174.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  175.             vs_push(l);
  176.         vs_base = vs_top;
  177.         while (base < top)
  178.             vs_push(*base++);
  179.         (*fun->cc.cc_self)(top);
  180.         break;
  181.     }
  182.  
  183.     case t_cons:
  184.         funcall(fun);
  185.         break;
  186.  
  187.     default:
  188.         FEinvalid_function(fun);
  189.     }
  190. }
  191.  
  192. lispcall(funp, narg)
  193. object *funp;
  194. int narg;
  195. {
  196.     object fun = *funp;
  197.  
  198.     vs_base = funp + 1;
  199.     vs_top = vs_base + narg;
  200.  
  201.     if (fun == OBJNULL)
  202.         FEerror("Undefined function.", 0);
  203.     switch (type_of(fun)) {
  204.     case t_cfun:
  205.         MMcall(fun);
  206.         break;
  207.  
  208.     case t_cclosure:
  209.     {
  210.         object *top, *base, l;
  211.  
  212.         if (fun->cc.cc_turbo != NULL) {
  213.             MMccall(fun, fun->cc.cc_turbo);
  214.             break;
  215.         }
  216.         top = vs_top;
  217.         base = vs_base;
  218.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  219.             vs_push(l);
  220.         vs_base = vs_top;
  221.         while (base < top)
  222.             vs_push(*base++);
  223.         MMccall(fun, top);
  224.         break;
  225.     }
  226.  
  227.     case t_cons:
  228.         funcall(fun);
  229.         break;
  230.  
  231.     default:
  232.         FEinvalid_function(fun);
  233.     }
  234. }
  235.  
  236. lispcall_no_event(funp, narg)
  237. object *funp;
  238. int narg;
  239. {
  240.     object fun = *funp;
  241.  
  242.     vs_base = funp + 1;
  243.     vs_top = vs_base + narg;
  244.  
  245.     if (fun == OBJNULL)
  246.         FEerror("Undefined function.", 0);
  247.     switch (type_of(fun)) {
  248.     case t_cfun:
  249.         (*fun->cf.cf_self)();
  250.         break;
  251.  
  252.     case t_cclosure:
  253.     {
  254.         object *top, *base, l;
  255.  
  256.         if (fun->cc.cc_turbo != NULL) {
  257.             (*fun->cc.cc_self)(fun->cc.cc_turbo);
  258.             break;
  259.         }
  260.         top = vs_top;
  261.         base = vs_base;
  262.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  263.             vs_push(l);
  264.         vs_base = vs_top;
  265.         while (base < top)
  266.             vs_push(*base++);
  267.         (*fun->cc.cc_self)(top);
  268.         break;
  269.     }
  270.  
  271.     case t_cons:
  272.         funcall(fun);
  273.         break;
  274.  
  275.     default:
  276.         FEinvalid_function(fun);
  277.     }
  278. }
  279.  
  280. symlispcall(sym, base, narg)
  281. object sym, *base;
  282. int narg;
  283. {
  284.     object fun = symbol_function(sym);
  285.  
  286.     vs_base = base;
  287.     vs_top = vs_base + narg;
  288.  
  289.     if (fun == OBJNULL)
  290.         FEerror("Undefined function.", 0);
  291.     switch (type_of(fun)) {
  292.     case t_cfun:
  293.         MMcall(fun);
  294.         break;
  295.  
  296.     case t_cclosure:
  297.     {
  298.         object *top, *base, l;
  299.  
  300.         if (fun->cc.cc_turbo != NULL) {
  301.             MMccall(fun, fun->cc.cc_turbo);
  302.             break;
  303.         }
  304.         top = vs_top;
  305.         base = vs_base;
  306.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  307.             vs_push(l);
  308.         vs_base = vs_top;
  309.         while (base < top)
  310.             vs_push(*base++);
  311.         MMccall(fun, top);
  312.         break;
  313.     }
  314.  
  315.     case t_cons:
  316.         funcall(fun);
  317.         break;
  318.  
  319.     default:
  320.         FEinvalid_function(fun);
  321.     }
  322. }
  323.  
  324. symlispcall_no_event(sym, base, narg)
  325. object sym, *base;
  326. int narg;
  327. {
  328.     object fun = symbol_function(sym);
  329.  
  330.     vs_base = base;
  331.     vs_top = vs_base + narg;
  332.  
  333.     if (fun == OBJNULL)
  334.         FEerror("Undefined function.", 0);
  335.     switch (type_of(fun)) {
  336.     case t_cfun:
  337.         (*fun->cf.cf_self)();
  338.         break;
  339.  
  340.     case t_cclosure:
  341.     {
  342.         object *top, *base, l;
  343.  
  344.         if (fun->cc.cc_turbo != NULL) {
  345.             (*fun->cc.cc_self)(fun->cc.cc_turbo);
  346.             break;
  347.         }
  348.         top = vs_top;
  349.         base = vs_base;
  350.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  351.             vs_push(l);
  352.         vs_base = vs_top;
  353.         while (base < top)
  354.             vs_push(*base++);
  355.         (*fun->cc.cc_self)(top);
  356.         break;
  357.     }
  358.  
  359.     case t_cons:
  360.         funcall(fun);
  361.         break;
  362.  
  363.     default:
  364.         FEinvalid_function(fun);
  365.     }
  366. }
  367.  
  368. object
  369. simple_lispcall(funp, narg)
  370. object *funp;
  371. int narg;
  372. {
  373.     object fun = *funp;
  374.     object *sup = vs_top;
  375.  
  376.     vs_base = funp + 1;
  377.     vs_top = vs_base + narg;
  378.  
  379.     if (fun == OBJNULL)
  380.         FEerror("Undefined function.", 0);
  381.     switch (type_of(fun)) {
  382.     case t_cfun:
  383.         MMcall(fun);
  384.         break;
  385.  
  386.     case t_cclosure:
  387.     {
  388.         object *top, *base, l;
  389.  
  390.         if (fun->cc.cc_turbo != NULL) {
  391.             MMccall(fun, fun->cc.cc_turbo);
  392.             break;
  393.         }
  394.         top = vs_top;
  395.         base = vs_base;
  396.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  397.             vs_push(l);
  398.         vs_base = vs_top;
  399.         while (base < top)
  400.             vs_push(*base++);
  401.         MMccall(fun, top);
  402.         break;
  403.     }
  404.  
  405.     case t_cons:
  406.         funcall(fun);
  407.         break;
  408.  
  409.     default:
  410.         FEinvalid_function(fun);
  411.     }
  412.     vs_top = sup;
  413.     return(vs_base[0]);
  414. }
  415.  
  416. object
  417. simple_lispcall_no_event(funp, narg)
  418. object *funp;
  419. int narg;
  420. {
  421.     object fun = *funp;
  422.     object *sup = vs_top;
  423.  
  424.     vs_base = funp + 1;
  425.     vs_top = vs_base + narg;
  426.  
  427.     if (fun == OBJNULL)
  428.         FEerror("Undefined function.", 0);
  429.     switch (type_of(fun)) {
  430.     case t_cfun:
  431.         (*fun->cf.cf_self)();
  432.         break;
  433.  
  434.     case t_cclosure:
  435.     {
  436.         object *top, *base, l;
  437.  
  438.         if (fun->cc.cc_turbo != NULL) {
  439.             (*fun->cc.cc_self)(fun->cc.cc_turbo);
  440.             break;
  441.         }
  442.         top = vs_top;
  443.         base = vs_base;
  444.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  445.             vs_push(l);
  446.         vs_base = vs_top;
  447.         while (base < top)
  448.             vs_push(*base++);
  449.         (*fun->cc.cc_self)(top);
  450.         break;
  451.     }
  452.  
  453.     case t_cons:
  454.         funcall(fun);
  455.         break;
  456.  
  457.     default:
  458.         FEinvalid_function(fun);
  459.     }
  460.     vs_top = sup;
  461.     return(vs_base[0]);
  462. }
  463.  
  464. object
  465. simple_symlispcall(sym, base, narg)
  466. object sym, *base;
  467. int narg;
  468. {
  469.     object fun = symbol_function(sym);
  470.     object *sup = vs_top;
  471.  
  472.     vs_base = base;
  473.     vs_top = vs_base + narg;
  474.  
  475.     if (fun == OBJNULL)
  476.         FEerror("Undefined function.", 0);
  477.     switch (type_of(fun)) {
  478.     case t_cfun:
  479.         MMcall(fun);
  480.         break;
  481.  
  482.     case t_cclosure:
  483.     {
  484.         object *top, *base, l;
  485.  
  486.         if (fun->cc.cc_turbo != NULL) {
  487.             MMccall(fun, fun->cc.cc_turbo);
  488.             break;
  489.         }
  490.         top = vs_top;
  491.         base = vs_base;
  492.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  493.             vs_push(l);
  494.         vs_base = vs_top;
  495.         while (base < top)
  496.             vs_push(*base++);
  497.         MMccall(fun, top);
  498.         break;
  499.     }
  500.  
  501.     case t_cons:
  502.         funcall(fun);
  503.         break;
  504.  
  505.     default:
  506.         FEinvalid_function(fun);
  507.     }
  508.     vs_top = sup;
  509.     return(vs_base[0]);
  510. }
  511.  
  512. object
  513. simple_symlispcall_no_event(sym, base, narg)
  514. object sym, *base;
  515. int narg;
  516. {
  517.     object fun = symbol_function(sym);
  518.     object *sup = vs_top;
  519.  
  520.     vs_base = base;
  521.     vs_top = vs_base + narg;
  522.  
  523.     if (fun == OBJNULL)
  524.         FEerror("Undefined function.", 0);
  525.     switch (type_of(fun)) {
  526.     case t_cfun:
  527.         (*fun->cf.cf_self)();
  528.         break;
  529.  
  530.     case t_cclosure:
  531.     {
  532.         object *top, *base, l;
  533.  
  534.         if (fun->cc.cc_turbo != NULL) {
  535.             (*fun->cc.cc_self)(fun->cc.cc_turbo);
  536.             break;
  537.         }
  538.         top = vs_top;
  539.         base = vs_base;
  540.         for (l = fun->cc.cc_env;  !endp(l);  l = l->c.c_cdr)
  541.             vs_push(l);
  542.         vs_base = vs_top;
  543.         while (base < top)
  544.             vs_push(*base++);
  545.         (*fun->cc.cc_self)(top);
  546.         break;
  547.     }
  548.  
  549.     case t_cons:
  550.         funcall(fun);
  551.         break;
  552.  
  553.     default:
  554.         FEinvalid_function(fun);
  555.     }
  556.     vs_top = sup;
  557.     return(vs_base[0]);
  558. }
  559.  
  560. super_funcall(fun)
  561. object fun;
  562. {
  563.     if (type_of(fun) == t_symbol) {
  564.         if (fun->s.s_sfdef != NOT_SPECIAL || fun->s.s_mflag)
  565.             FEinvalid_function(fun);
  566.         if (fun->s.s_gfdef == OBJNULL)
  567.             FEundefined_function(fun);
  568.         fun = fun->s.s_gfdef;
  569.     }
  570.     funcall(fun);
  571. }
  572.  
  573. super_funcall_no_event(fun)
  574. object fun;
  575. {
  576.     if (type_of(fun) == t_symbol) {
  577.         if (fun->s.s_sfdef != NOT_SPECIAL || fun->s.s_mflag)
  578.             FEinvalid_function(fun);
  579.         if (fun->s.s_gfdef == OBJNULL)
  580.             FEundefined_function(fun);
  581.         fun = fun->s.s_gfdef;
  582.     }
  583.     funcall_no_event(fun);
  584. }
  585.  
  586. eval(form)
  587. object form;
  588. {
  589.     object fun, x;
  590.     object *top;
  591.     object *base;
  592.  
  593.     cs_check(form);
  594.  
  595. EVAL:
  596.  
  597.     vs_check;
  598.  
  599.     if (Vevalhook->s.s_dbind != Cnil && eval1 == 0)
  600.     {
  601.         bds_ptr old_bds_top = bds_top;
  602.         object hookfun = symbol_value(Vevalhook);
  603.         /*  check if Vevalhook is unbound  */
  604.  
  605.         bds_bind(Vevalhook, Cnil);
  606.         vs_base = vs_top;
  607.         vs_push(form);
  608.         vs_push(lex_env[0]);
  609.         vs_push(lex_env[1]);
  610.         vs_push(lex_env[2]);
  611.         vs_push(Cnil);
  612.         stack_cons();
  613.         stack_cons();
  614.         stack_cons();
  615.         super_funcall(hookfun);
  616.         bds_unwind(old_bds_top);
  617.         return;
  618.     } else
  619.         eval1 = 0;
  620.  
  621.     if (type_of(form) == t_cons)
  622.         goto APPLICATION;
  623.  
  624.     if (type_of(form) != t_symbol) {
  625.         vs_base = vs_top;
  626.         vs_push(form);
  627.         return;
  628.     }
  629.  
  630. SYMBOL:
  631.     switch (form->s.s_stype) {
  632.     case stp_constant:
  633.         vs_base = vs_top;
  634.         vs_push(form->s.s_dbind);
  635.         return;
  636.  
  637.     case stp_special:
  638.         if(form->s.s_dbind == OBJNULL)
  639.             FEunbound_variable(form);
  640.         vs_base = vs_top;
  641.         vs_push(form->s.s_dbind);
  642.         return;
  643.  
  644.     default:
  645.         /*  x = lex_var_sch(form);  */
  646.         for (x = lex_env[0];  type_of(x) == t_cons;  x = x->c.c_cdr)
  647.             if (x->c.c_car->c.c_car == form) {
  648.                 x = x->c.c_car->c.c_cdr;
  649.                 if (endp(x))
  650.                     break;
  651.                 vs_base = vs_top;
  652.                 vs_push(x->c.c_car);
  653.                 return;
  654.             }
  655.         if(form->s.s_dbind == OBJNULL)
  656.             FEunbound_variable(form);
  657.         vs_base = vs_top;
  658.         vs_push(form->s.s_dbind);
  659.         return;
  660.     }
  661.  
  662. APPLICATION:
  663.     fun = MMcar(form);
  664.     if (type_of(fun) != t_symbol)
  665.         goto LAMBDA;
  666.     if (fun->s.s_sfdef != NOT_SPECIAL) {
  667.         ihs_check;
  668.         ihs_push(fun);
  669.         ihs_top->ihs_base = lex_env;
  670.         (*fun->s.s_sfdef)(MMcdr(form));
  671.         ihs_pop();
  672.         return;
  673.     }
  674.     /*  x = lex_fd_sch(fun);  */
  675.     for (x = lex_env[1];  type_of(x) == t_cons;  x = x->c.c_cdr)
  676.         if (x->c.c_car->c.c_car == fun) {
  677.             x = x->c.c_car;
  678.             if (MMcadr(x) == Smacro) {
  679.                 x = MMcaddr(x);
  680.                 goto EVAL_MACRO;
  681.             }
  682.             x = MMcaddr(x);
  683.             goto EVAL_ARGS;
  684.         }
  685.  
  686. GFDEF:
  687.     if ((x = fun->s.s_gfdef) == OBJNULL)
  688.         FEundefined_function(fun);
  689.  
  690.     if (fun->s.s_mflag) {
  691.     EVAL_MACRO:
  692.         top = vs_top;
  693.         macro_expand1(x, form);
  694.         form = vs_base[0];
  695.         vs_top = top;
  696.         vs_push(form);
  697.         goto EVAL;
  698.     }
  699.  
  700. EVAL_ARGS:
  701.     vs_push(x);
  702.     form = form->c.c_cdr;
  703.     base = vs_top;
  704.     top = vs_top;
  705.     while(!endp(form)) {
  706.         eval(MMcar(form));
  707.         top[0] = vs_base[0];
  708.         vs_top = ++top;
  709.         form = MMcdr(form);
  710.     }
  711.     vs_base = base;
  712.     if (Vapplyhook->s.s_dbind != Cnil) {
  713.         call_applyhook(fun);
  714.         return;
  715.     }
  716.     if (type_of(x) == t_cfun) {
  717.         MMcall(x);
  718.     } else
  719.         funcall(x);
  720.     return;
  721.  
  722. LAMBDA:
  723.     if (type_of(fun) == t_cons && MMcar(fun) == Slambda) {
  724.         temporary = make_cons(lex_env[2], fun->c.c_cdr);
  725.         temporary = make_cons(lex_env[1], temporary);
  726.         temporary = make_cons(lex_env[0], temporary);
  727.         x = make_cons(Slambda_closure, temporary);
  728.         vs_push(x);
  729.         goto EVAL_ARGS;
  730.     }
  731.     FEinvalid_function(fun);
  732. }    
  733.  
  734. call_applyhook(fun)
  735. object fun;
  736. {
  737.     object ah;
  738.     object *v;
  739.  
  740.     ah = symbol_value(Vapplyhook);
  741.     v = vs_base + 1;
  742.     vs_push(Cnil);
  743.     while (vs_top > v)
  744.         stack_cons();
  745.     vs_push(vs_base[0]);
  746.     vs_base[0] = fun;
  747.     vs_push(lex_env[0]);
  748.     vs_push(lex_env[1]);
  749.     vs_push(lex_env[2]);
  750.     vs_push(Cnil);
  751.     stack_cons();
  752.     stack_cons();
  753.     stack_cons();
  754.     super_funcall(ah);
  755. }
  756.  
  757. Lfuncall()
  758. {
  759.     if (vs_top-vs_base < 1)
  760.         too_few_arguments();
  761.     vs_base++;
  762.     super_funcall(vs_base[-1]);
  763. }
  764.  
  765. Lapply()
  766. {
  767.     object lastarg;
  768.     if (vs_top-vs_base < 2)
  769.         too_few_arguments();
  770.     lastarg = vs_pop;
  771.     while (!endp(lastarg)) {
  772.         vs_push(MMcar(lastarg));
  773.         lastarg = MMcdr(lastarg);
  774.     }
  775.     vs_base++;
  776.     super_funcall(vs_base[-1]);
  777. }
  778.  
  779. Leval()
  780. {
  781.     object *lex = lex_env;
  782.  
  783.     check_arg(1);
  784.     lex_new();
  785.     eval(vs_base[0]);
  786.     lex_env = lex;
  787. }
  788.  
  789. Levalhook()
  790. {
  791.     object env;
  792.     bds_ptr old_bds_top = bds_top;
  793.     object *lex = lex_env;
  794.     int n = vs_top - vs_base;
  795.  
  796.     lex_env = vs_top;
  797.     if (n < 3)
  798.         too_few_arguments();
  799.     else if (n == 3) {
  800.         *(struct nil3 *)vs_top = three_nils;
  801.         vs_top += 3;
  802.     } else if (n == 4) {
  803.         env = vs_base[3];
  804.         vs_push(car(env));
  805.         env = cdr(env);
  806.         vs_push(car(env));
  807.         env = cdr(env);
  808.         vs_push(car(env));
  809.     } else
  810.         too_many_arguments();
  811.     bds_bind(Vevalhook, vs_base[1]);
  812.     bds_bind(Vapplyhook, vs_base[2]);
  813.     eval1 = 1;
  814.     eval(vs_base[0]);
  815.     lex_env = lex;
  816.     bds_unwind(old_bds_top);
  817. }
  818.  
  819. Lapplyhook()
  820. {
  821.     object env;
  822.     bds_ptr old_bds_top = bds_top;
  823.     object *lex = lex_env;
  824.     int n = vs_top - vs_base;
  825.     object l, *z;
  826.  
  827.     lex_env = vs_top;
  828.     if (n < 4)
  829.         too_few_arguments();
  830.     else if (n == 4) {
  831.         *(struct nil3 *)vs_top = three_nils;
  832.         vs_top += 3;
  833.     } else if (n == 5) {
  834.         env = vs_base[4];
  835.         vs_push(car(env));
  836.         env = cdr(env);
  837.         vs_push(car(env));
  838.         env = cdr(env);
  839.         vs_push(car(env));
  840.     } else
  841.         too_many_arguments();
  842.     bds_bind(Vevalhook, vs_base[2]);
  843.     bds_bind(Vapplyhook, vs_base[3]);
  844.     z = vs_top;
  845.     for (l = vs_base[1];  !endp(l);  l = l->c.c_cdr)
  846.         vs_push(l->c.c_car);
  847.     l = vs_base[0];
  848.     vs_base = z;
  849.     super_funcall(l);
  850.     lex_env = lex;
  851.     bds_unwind(old_bds_top);
  852. }
  853.  
  854. Lconstantp()
  855. {
  856.     enum type x;
  857.     check_arg(1);
  858.  
  859.     x = type_of(vs_base[0]);
  860.     if(x == t_cons)
  861.         if(vs_base[0]->c.c_car == Squote)
  862.             vs_base[0] = Ct;
  863.         else    vs_base[0] = Cnil;
  864.     else if(x == t_symbol)
  865.         if((enum stype)vs_base[0]->s.s_stype == stp_constant)
  866.             vs_base[0] = Ct;
  867.         else
  868.             vs_base[0] = Cnil;
  869.     else
  870.             vs_base[0] = Ct;
  871. }
  872.  
  873. object
  874. ieval(x)
  875. object x;
  876. {
  877.     object *old_vs_base;
  878.     object *old_vs_top;
  879.  
  880.     old_vs_base = vs_base;
  881.     old_vs_top = vs_top;
  882.     eval(x);
  883.     x = vs_base[0];
  884.     vs_base = old_vs_base;
  885.     vs_top = old_vs_top;
  886.     return(x);
  887. }
  888.  
  889. object
  890. ifuncall1(fun, arg1)
  891. object fun, arg1;
  892. {
  893.     object *old_vs_base;
  894.     object *old_vs_top;
  895.     object x;
  896.  
  897.     old_vs_base = vs_base;
  898.     old_vs_top = vs_top;
  899.     vs_base = vs_top;
  900.     vs_push(arg1);
  901.     super_funcall(fun);
  902.     x = vs_base[0];
  903.     vs_top = old_vs_top;
  904.     vs_base = old_vs_base;
  905.     return(x);
  906. }
  907.  
  908. object
  909. ifuncall2(fun, arg1, arg2)
  910. object fun, arg1, arg2;
  911. {
  912.     object *old_vs_base;
  913.     object *old_vs_top;
  914.     object x;
  915.  
  916.     old_vs_base = vs_base;
  917.     old_vs_top = vs_top;
  918.     vs_base = vs_top;
  919.     vs_push(arg1);
  920.     vs_push(arg2);
  921.     super_funcall(fun);
  922.     x = vs_base[0];
  923.     vs_top = old_vs_top;
  924.     vs_base = old_vs_base;
  925.     return(x);
  926. }
  927.  
  928. object
  929. ifuncall3(fun, arg1, arg2, arg3)
  930. object fun, arg1, arg2, arg3;
  931. {
  932.     object *old_vs_base;
  933.     object *old_vs_top;
  934.     object x;
  935.  
  936.     old_vs_base = vs_base;
  937.     old_vs_top = vs_top;
  938.     vs_base = vs_top;
  939.     vs_push(arg1);
  940.     vs_push(arg2);
  941.     vs_push(arg3);
  942.     super_funcall(fun);
  943.     x = vs_base[0];
  944.     vs_top = old_vs_top;
  945.     vs_base = old_vs_base;
  946.     return(x);
  947. }
  948.  
  949. funcall_with_catcher(fname, fun)
  950. object fname, fun;
  951. {
  952.     int n = vs_top - vs_base;
  953.     if (n > 64) n = 64;
  954.     frs_push(FRS_CATCH, make_cons(fname, make_fixnum(n)));
  955.     if (nlj_active)
  956.         nlj_active = FALSE;
  957.     else
  958.         funcall(fun);
  959.     frs_pop();
  960. }
  961.  
  962. init_eval()
  963. {
  964.         make_constant("CALL-ARGUMENTS-LIMIT", make_fixnum(64));
  965.  
  966.     Sapply = make_function("APPLY", Lapply);
  967.     enter_mark_origin(&Sapply);
  968.     Sfuncall = make_function("FUNCALL", Lfuncall);
  969.     enter_mark_origin(&Sfuncall);
  970.  
  971.     Vevalhook = make_special("*EVALHOOK*", Cnil);
  972.     Vapplyhook = make_special("*APPLYHOOK*", Cnil);
  973.  
  974.     temporary = Cnil;
  975.     enter_mark_origin(&temporary);
  976.  
  977.     three_nils.nil3_self[0] = Cnil;
  978.     three_nils.nil3_self[1] = Cnil;
  979.     three_nils.nil3_self[2] = Cnil;
  980.  
  981.     make_function("EVAL", Leval);
  982.     make_function("EVALHOOK", Levalhook);
  983.     make_function("APPLYHOOK", Lapplyhook);
  984.     make_function("CONSTANTP", Lconstantp);
  985. }
  986.